home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / html_images.tcl.z / html_images.tcl
Text File  |  2002-07-08  |  15KB  |  566 lines
  1. # images.tcl
  2. # Supply an image callback function
  3. # Read in an image if we don't already have one
  4. # callback to library for display
  5. #           Inline Images
  6. # This interface is subject to change
  7. # Most of the work is getting around a limitation of TK that prevents
  8. # setting the size of a label to a widthxheight in pixels
  9. #
  10. # Images have the following parameters:
  11. #    align:  top,middle,bottom
  12. #    alt:    alternate text
  13. #    ismap:  A clickable image map
  14. #    src:    The URL link
  15. # Netscape supports (and so do we)
  16. #    width:  A width hint (in pixels)
  17. #    height:  A height hint (in pixels)
  18. #    border: The size of the window border
  19.  
  20. set imagecachesize 25
  21. proc Image_Reset {win} {
  22.     global imagecache imagecachesize
  23.     foreach image [array names imagecache] {
  24.     ldelete imagecache($image) $win
  25.     }
  26.     set images [image names]
  27.     set nuke [expr [llength $images] - $imagecachesize]
  28.     if {$nuke > 0} {
  29.     foreach image $images {
  30.         if {[info exists imagecache($image)] &&
  31.             [llength $imagecache($image)] == 0} {
  32.         unset imagecache($image)
  33.         image delete $image
  34.         incr nuke -1
  35.         if {$nuke <= 0} {
  36.             break
  37.         }
  38.         }
  39.     }
  40.     }
  41. }
  42.  
  43. proc HMtag_img {win param text} {
  44.     upvar #0 HM$win var Head$win head
  45.     global window
  46.  
  47.     if {!$window(imagesEnabled)} {
  48.         Exmh_Debug Skipping image $param
  49.         return
  50.     }
  51.  
  52.     # set imagemap callbacks
  53.     set mark [Mark_Current $win]
  54.     set target ""
  55.     set url ""
  56.     set islink 0
  57.     set border 0
  58.     catch {set target $var(Fref)}    ;# target frame name
  59.     if [info exists var(Lref)] {
  60.         set url $var(Lref)
  61.         set islink 1
  62.         set border 2
  63.         if {[HMextract_param $param ismap]} {
  64.         append url ?%x,%y
  65.         }
  66.     }
  67.  
  68.     # get alignment
  69.     array set align_map {top top    middle center    bottom bottom}
  70.     set align bottom ;# The spec isn't clear what the default should be
  71.     HMextract_param $param align
  72.     if ![info exists align_map([string tolower $align])] {
  73.         set align center
  74.     } else {
  75.         set align $align_map([string tolower $align])
  76.     }
  77.  
  78.     # get alternate text
  79.     set alt "<image>"
  80.     HMextract_param $param alt
  81.     set alt [HMmap_esc $alt]
  82.  
  83.     # get the border width
  84.     HMextract_param $param border
  85.     if [regexp -nocase none $border] {
  86.         set border 0
  87.     }
  88.  
  89.     # see if we have an image size hint
  90.     # If so, make a frame the "hint" size to put the label in
  91.     # otherwise just make the label
  92.     set item $win.$var(tags)
  93.     # catch {destroy $item}
  94.     if {[HMextract_param $param width] && [HMextract_param $param height]} {
  95.         catch {incr width $border}
  96.         catch {incr height $border}
  97.         frame $item -width $width -height $height
  98.         Head_Color $win $item $islink
  99.         pack propagate $item 0
  100.         dputs got image size: $width x $height $alt
  101.         set label $item.label
  102.         label $label -bd 0
  103.         pack $label -expand 1 -fill both
  104.     } else {
  105.         set label $item
  106.         label $label -bd 0
  107.         dputs got image $alt
  108.     }
  109.  
  110.     bind $label <ButtonRelease> \
  111.         [list ImageHit $win $label $mark $url $target]
  112.     if {$islink} {
  113.         $label config -cursor hand2
  114.     }
  115.  
  116.     $label configure -relief ridge -fg orange -text $alt
  117.     catch {$label configure -highlightthickness $border}
  118.     Head_Color $win $label $islink
  119.     Win_Install $win $item -padx 0 -pady 0 -align $align
  120.  
  121.     # now callback to the application
  122.     set src ""
  123.     HMextract_param $param src
  124.     if [info exists var(base)] {
  125.         set src_orig $src
  126.         set param_orig $param
  127.         UrlResolve $var(base) src
  128.         UrlRelative $var(S_url) src
  129.         regsub $src_orig $param_orig $src param
  130.         # Update the mark that represents the HTML
  131.         Mark_Htag $win [Mark_Current $win] "img $param"
  132.     }
  133.     HMset_image $win $label $src
  134.     return $label    ;# used by the forms package for input_image types
  135. }
  136.  
  137. # The app needs to supply one of these
  138. #proc HMset_image {win handle src} {
  139. #    dputs "Found an image <$src> to put in $handle"
  140. #    HMgot_image $win $handle "can't get\n$src"
  141. #}
  142.  
  143. # When the image is available, the application should call back here.
  144. # If we have the image, put it in the label, otherwise display the error
  145. # message.  If we don't get a callback, the "alt" text remains.
  146. # if we have a clickable image, arrange for a callback
  147.  
  148. proc HMgot_image {win label image_error} {
  149.     global imagecache
  150.     # if we're in a frame turn on geometry propogation
  151.     $label config -relief flat
  152.     if {[winfo name $label] == "label"} {
  153.     pack propagate [winfo parent $win] 1
  154.     }
  155.     if {[catch {$label configure -image $image_error}]} {
  156.     $label configure -image {}
  157.     $label configure -text $image_error
  158.     } else {
  159.     # Record which images are in use by this page
  160.     set name [$label cget -image]
  161.     set ix -1
  162.     catch {set ix [lsearch $imagecache($name) $win]}
  163.     if {$ix < 0} {
  164.         lappend imagecache($name) $win
  165.     }
  166.     }
  167. }
  168.  
  169. # This is called by the HTML library when it hits an image
  170. # We call HMgot_image when we have finished fetching the image
  171.  
  172. proc HMset_image {win label href} {
  173.     upvar #0 HM$win var
  174.     upvar #0 Image$win image
  175.  
  176.     set base $var(S_url)
  177.     set type photo
  178.  
  179.     set mark [Mark_Current $win]
  180.     if [info exists var(Lref)] {
  181.     regsub -all % $var(Lref) %% url2
  182.     bind $label <Enter> +[list Status $win $url2]
  183.     bind $label <Leave> +[list Status $win ""]
  184.     } else {
  185.     set url2 {}
  186.     }
  187.  
  188.     set protocol [UrlResolve $base href]    ;# Side-effects href
  189.     lappend image(widgets) $label
  190.     switch -regexp -- $protocol {
  191.     (http|ftp) {
  192.         if {[string first " $href " " [image names] "] >= 0} {
  193.         HMgot_image $win $label $href
  194.         } else {
  195.         set cache [Cache_GetFile $href]
  196.         set ok 0
  197.         if [file exists $cache] {
  198.             upvar #0 $href data
  199.             Status $win "cached image $href"
  200.             set data(what) file
  201.             set data(file) $cache
  202.             set ok [ImageFetched $win $label $href $mark]
  203.         }
  204.         if !$ok {
  205.             Status $win "fetching image $href"
  206.             FeedbackLoop $win "image"
  207.             Http_get $href [list ImageFetched $win $label $href $mark] \
  208.                     [list Image_Progress $win $label $href]
  209.         }
  210.         }
  211.     }
  212.     file {
  213.         upvar #0 $href data
  214.         regsub {(file:(//?localhost)?)} $href {} file
  215.         regsub {^/+} $file / file
  216.         if {![catch {image create $type $href -file $file} message]} {
  217.         set data(what) file
  218.         HMgot_image $win $label $href
  219.         } else {
  220.         set data(what) error
  221.         set data(message) $message
  222.         Status $win $message
  223.         }
  224.     }
  225.     }
  226.     return
  227. }
  228. # image fetch complete.  Make an image and do callback
  229.  
  230. proc ImageFetched {win label href mark} {
  231.     upvar #0 $href data
  232.     if {[string first " $href " " [image names] "] >= 0} {
  233.     # Parallel requeusts may mean that this is already created.
  234.     HMgot_image $win $label $href
  235.     return
  236.     }
  237.     set palette ""
  238.     set type image
  239.     catch {set type $data(type)}
  240.     switch -glob -- $type {
  241.     *bitmap { set type bitmap }
  242.     default { set type photo ; set palette "-palette 5/5/5" }
  243.     }
  244.     Exmh_Debug ImageFetched what $data(what) $href
  245.     if {$data(what) == "file"} {
  246.     Status_push $win "rendering image $href"
  247.     global TRANSPARENT_GIF_COLOR    ;# Backdoor into photo widget
  248.     set TRANSPARENT_GIF_COLOR [$win cget -bg]
  249.     if {![catch {eval {image create $type $href -file $data(file)} $palette} message]} {
  250.         HMgot_image $win $label $href
  251.         dputs ImageFetched $label $href
  252.         Status_pop $win
  253.         update
  254.         return 1
  255.     } else {
  256.         dputs Image Create Failed $message $label $href
  257.         Status $win $message
  258.         return 0
  259.     }
  260.     } elseif {$data(what) == "error"} {
  261.     upvar #0 Image$win img
  262.     set img($label) $data(message)
  263.     return 0
  264.     }
  265. }
  266.  
  267. proc Image_EditMode {win edit} {
  268.     upvar #0 Image$win image
  269.     if ![info exists image(widgets)] {
  270.     return
  271.     }
  272.     foreach w $image(widgets) {
  273.     if ![winfo exists $w] {
  274.         set ix [lsearch $image(widgets) $w]
  275.         set image(widgets) [lreplace $image(widgets) $ix $ix]
  276.         continue
  277.     }
  278.     if {$edit} {
  279.         bindtags $w [list ImageEdit $w]
  280.     } else {
  281.         bindtags $w [list $w [winfo class $w] [winfo toplevel $w] all]
  282.     }
  283.     }
  284.  
  285. }
  286.  
  287. proc ImageHit {win label mark url target} {
  288.     set win0 [Window_GetMaster $win]
  289.     if {[winfo class [winfo parent $win0]] == "Msg"} {
  290.     # exmh inline display
  291.     URI_StartViewer $url
  292.     } elseif {[Input_Edit $win]} {
  293.     ImageEdit $win $label $mark
  294.     } elseif {$url != {}} {
  295.     Frame_Display $win $target $url
  296.     }
  297. }
  298. #bind ImageEdit <Enter> {FormHighlightWidget %W}
  299. #bind ImageEdit <Leave> {FormUnHighlightWidget %W}
  300.  
  301. # Copy an image to the local file system
  302. proc Image_Save {win} {
  303.     upvar #0 HM$win var
  304.  
  305.     set base $var(S_url)
  306.  
  307.     Log $win Image_Save
  308.     # Get the selection and look for images in it.
  309.     if [catch {Output_string $win sel.first sel.last} html] {
  310.     Status $win "Select images first"
  311.     return
  312.     }
  313.     set state(images) {}
  314.     HMparse_html $html [list ImageScan $win state] {}
  315.  
  316.     foreach href $state(images) {
  317.     set protocol [UrlResolve $base href]    ;# Side-effects href
  318.     
  319.     switch -regexp -- $protocol {
  320.         (http|ftp) {
  321.         # Should use the cache
  322.         Status $win "fetching image $href"
  323.         FeedbackLoop $win image
  324.         Http_get $href [list ImageSave $win $href] \
  325.                 [list Url_Progress $win $href]
  326.         }
  327.         file {
  328.         ImageSave $win $href
  329.         }
  330.     }
  331.     }
  332.     return
  333. }
  334.  
  335. proc ImageScan {win stateVar htag not param text} {
  336.     upvar 2 $stateVar state    ;# Image_Save -> HMparse_html -> ImageScan
  337.     if {[regexp -nocase ^img $htag] &&
  338.     [HMextract_param $param src] &&
  339.     [info exists src]} {
  340.     lappend state(images) $src
  341.     }
  342. }
  343.  
  344. proc ImageSave {win href} {
  345.     upvar #0 $href data
  346.     global image
  347.     if {![info exists image(dir)] ||
  348.     ![file isdirectory $image(dir)]} {
  349.     Image_SaveDir $win
  350.     }
  351.     if ![info exists data(file)] {
  352.     return
  353.     }
  354.     set path [glob -nocomplain $image(dir)]/[file tail $href]
  355.     if [catch {exec mv -f $data(file) $path} err] {
  356.     Log $win ImageSave $data(file) $err
  357.     Status $win $err
  358.     } else {
  359.     Log $win ImageSave $href $path
  360.     Status $win "Saved $path"
  361.     }
  362. }
  363. proc Image_SaveDir {win} {
  364.     upvar #0 HM$win var
  365.     global image
  366.     if ![info exists image(dir)] {
  367.     set image(dir) ~/public_html/images
  368.     }
  369.     DialogEntry $win .imagesave "Directory for saved images" \
  370.         [list ImageSaveDir $win] \
  371.         [list [list "Directory" $image(dir)]]
  372. }
  373. proc ImageSaveDir {win newdir} {
  374.     global image
  375.     set image(dir) $newdir
  376.     if {[string length $image(dir)] && ![file exists $image(dir)]} {
  377.     if [catch {
  378.         exec mkdir [glob [file dirname $image(dir)]]/[file tail $image(dir)]
  379.     } err] {
  380.         Status $win $err
  381.     }
  382.     }
  383.     Log $win "Image_SaveDir $image(dir)"
  384.     Status $win "Image dir $image(dir)"
  385. }
  386. proc Image_Progress {win label href state current total} {
  387.  
  388.     if {$state == "queued"} return
  389.     regsub -all {\.} $href {!} name
  390.     dputs $current $total $href
  391.     if {$state == "done"} {
  392.     catch {destroy $label.bar}
  393.     return
  394.     }
  395.     if ![winfo exists $label] {
  396.     # Deleted out from under us.
  397.     Http_kill $href
  398.     return
  399.     }
  400.     if ![winfo exists $label.bar] {
  401.     frame $label.bar -bg blue
  402.     }
  403.  
  404.     if {$total > 0} {
  405.         place $label.bar -in $label \
  406.         -x 0 -y 0 -anchor nw -relheight 1.0 \
  407.         -relwidth [expr double($current) / $total.0]
  408.     }
  409.     update idletasks
  410. }
  411.  
  412. proc Image_Create { win {htag {}} } {
  413.     Log $win Image_Create
  414.     set state [Dialog_Htag $win {img src=! alt= width= height= align= border=} {} \
  415.     "Image specification" [list ImageDialogHook $win insert]]
  416.     if [llength $state] {
  417.     Undo_Mark $win ImageCreate
  418.     ImageInsert $win [lindex $state 1]
  419.     Undo_Mark $win ImageCreateEnd
  420.     }
  421. }
  422. proc ImageInsert {win param} {
  423.     if [HMextract_param $param href] {
  424.     # Pseudo href attribute for links and ismaps
  425.     regsub href=\"?$href\"? $param {} param
  426.     set html "<a href=$href><img $param></a>"
  427.     } else {
  428.     set html "<img $param>"
  429.     }
  430.     Input_Html $win $html        ;# results in Win_Install call
  431.     Input_Dirty $win
  432. }
  433. proc ImageDialogHook { win mark f {dialogVar {}} } {
  434.     upvar #0 $dialogVar dialog
  435.     lappend dialog(_names) ismap
  436.     set dialog(required,ismap) 0
  437. #    set dialog(required,href) 0
  438.     set g [frame $f.ismap -relief flat -bd 10]
  439.     if [HMextract_param $dialog(_values) ismap] {
  440.     set dialog(ismap) _SINGLETON_
  441.     }
  442.     checkbutton $g.ismap -text ISMAP -onvalue _SINGLETON_ -offvalue {} \
  443.     -variable $dialogVar\(ismap)
  444.     button $g.edit -text "Edit Map" \
  445.     -command [list ImageMapStart $win $dialogVar\(ismap) $dialog(src)]
  446.     button $g.href -text "Edit Link" -command [list ImageEditLink $win $mark]
  447.  
  448.     button $g.browse -text "Browse" -command [list ImageBrowse $win $dialogVar\(src)]
  449.     pack $g
  450.     pack $g.ismap $g.edit  $g.href $g.browse -side left -padx 5
  451.  
  452. }
  453. proc ImageEditLink {win mark} {
  454.     Text_MarkSet $win insert $mark
  455.     Text_TagRemove $win sel 1.0 end
  456.     Text_TagAdd $win sel insert "insert +1c"
  457.     DialogHtagCancel $win
  458.     after 1 [list Url_InsertLink $win]
  459. }
  460. proc ImageBrowse {win varname} {
  461.     upvar #0 $varname src HM$win var
  462.  
  463.     set abs $src
  464.     set default ""
  465.     UrlResolve $var(S_url) abs
  466.     if [regsub -nocase ^file: $abs {} abs] {
  467.     set default $abs
  468.     }
  469.     set file [fileselect "Select Image File" $default file]
  470.     if {[string length $file]} {
  471.     set file file:$file
  472.     UrlRelative $var(S_url) file
  473.     set src $file
  474.     }
  475. }
  476. proc ImageMapStart {win varName src} {
  477.     upvar #0 $varName ismap HM$win var
  478.     set proto [UrlResolve $var(S_url) src]
  479.     if {[string compare $proto file] != 0} {
  480.     upvar #0 $src data    ;# Image fetch state
  481.     if {[string compare $data(what) file] != 0} {
  482.         Status $win "Can't find the image"
  483.         return
  484.     }
  485.     set file $data(file)
  486.     } else {
  487.     regsub {(file:(//?localhost)?)} $src {} file
  488.     regsub {^/+} $file / file
  489.     }
  490.     IME_Init .ime $file
  491.     set ismap _SINGLETON_
  492.     DialogHtagOK $win
  493. }
  494.  
  495. proc ImageEdit { win label mark } {
  496.     upvar #0 Image$win img HM$win var
  497.     set htag [Mark_Htag $win $mark]
  498.     dputs $label $htag
  499.     Log $win ImageEdit $label $htag
  500.     # check for label inside a frame
  501.     if {[winfo class [winfo parent $label]] != "Text"} {
  502.     set widget [winfo parent $label]
  503.     } else {
  504.     set widget $label
  505.     }
  506.     set W [set H {}]
  507.     set msg "Edit image specification"
  508.     if [HMextract_param $htag src] {
  509.     UrlResolve $var(S_url) src
  510.     upvar #0 $src data    ;# http fetch state
  511.     if ![info exists data(what)] {
  512.         append msg "\n$src"
  513.     } else {
  514.         switch -- $data(what) {
  515.         "file" -
  516.         "done" {
  517.             # Compute size of real image
  518.             set W [winfo width $widget]
  519.             set H [winfo height $widget]
  520.         }
  521.         "connect" {
  522.             append msg "\n(no connection to src)"
  523.         }
  524.         "error" {
  525.             append msg "\n$data(message)"
  526.         }
  527.         "body" {
  528.             # Probably got an error message from the server
  529.             DialogHtmlError $data(html)
  530.             append msg "\n(note error popup)"
  531.         }
  532.         }
  533.     }
  534.     }
  535.     # Double check interaction between size and border specifications
  536.     set spec "img src=! alt= width=$W height=$H align= border="
  537.     set bd [$widget cget -highlightthickness]
  538.     set color [$widget cget -highlightbackground]
  539.     set image [$label cget -image]
  540.     if {[string compare $color "red"] == 0} {
  541.     $widget config -highlightbackground blue
  542.     } else {
  543.     $widget config -highlightbackground red
  544.     }
  545.     if {$bd == 0} {
  546.     $widget config -highlightthickness 2
  547.     }
  548.  
  549.     set state [Dialog_Htag $win $spec $htag $msg \
  550.         [list ImageDialogHook $win $widget]]
  551.     if [llength $state] {
  552.     global imagecache
  553.     Undo_Mark $win Image_Edit
  554.     Text_MarkSet $win  insert [$win index $widget]
  555.     Mark_ReadTags $win insert force
  556.     set html [Edit_CutRange $win $mark "$mark +1char"]
  557.     ldelete imagecache($image) $win
  558.     regsub {<img[^>]*>} $html "<img [lindex $state 1]>" html
  559.     Input_Html $win $html
  560.     Undo_Mark $win Image_EditEnd
  561.     } else {
  562.     $widget config -highlightthickness $bd -highlightbackground $color
  563.     }
  564.     LogEnd $win
  565. }
  566.